home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Thomas / run-collections-generic2.scm < prev    next >
Encoding:
Text File  |  1992-11-25  |  22.2 KB  |  433 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;*
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;*
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;*
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-collections-generic2.scm,v 1.1 1992/09/18 23:45:58 birkholz Exp $
  39.  
  40. ;;; This file is a continuation of runtime-collections-generic, which had
  41. ;;; to be split because of a limitation in the Gambit compiler.
  42.  
  43. ;;;;
  44. ;;;; FUNCTIONS FOR SEQUENCES (page 104)
  45. ;;;;
  46.  
  47. (define dylan:add
  48.   (dylan::generic-fn 'add one-sequence-and-an-object
  49.     (lambda rest
  50.       (dylan-call dylan:error
  51.           "add -- generic method not specialized for this collection"
  52.           rest))))
  53.  
  54. (define dylan:add!
  55.   (dylan::generic-fn 'add!
  56.       one-sequence-and-an-object
  57.       (lambda (seq obj)
  58.     (dylan-call dylan:add seq obj))))    ; Defaults to ADD
  59.  
  60.  
  61. (define dylan:add-new
  62.   (dylan::generic-fn
  63.    'add-new
  64.    (make-param-list `((SEQUENCE ,<sequence>) (OBJECT ,<object>))
  65.             #F #F '(test:))
  66.    #F))
  67.  
  68. (add-method
  69.  dylan:add-new
  70.  (dylan::dylan-callable->method
  71.   (make-param-list `((SEQUENCE ,<sequence>) (OBJECT ,<object>))
  72.            #F #F '(test:))
  73.   (lambda (multiple-values next-method seq object . rest)
  74.     multiple-values
  75.     (dylan::keyword-validate next-method rest '(test:))
  76.     (let ((test-fn (dylan::find-keyword rest 'test:
  77.                     (lambda () dylan:id?))))
  78.       (if (iterate-until (lambda (x) (dylan-call test-fn x object)) seq)
  79.       seq
  80.       (dylan-call dylan:add seq object))))))
  81.  
  82. (define dylan:add-new!
  83.   (dylan::generic-fn
  84.    'add-new
  85.    (make-param-list `((SEQUENCE ,<sequence>) (OBJECT ,<object>))
  86.             #F #F '(test:))
  87.    #F))
  88.  
  89. (add-method
  90.  dylan:add-new!
  91.  (dylan::dylan-callable->method
  92.   (make-param-list `((SEQUENCE ,<sequence>) (OBJECT ,<object>))
  93.            #F #F '(test:))
  94.   (lambda (multiple-values next-method seq object . rest)
  95.     multiple-values
  96.     (dylan::keyword-validate next-method rest '(test:))
  97.     (let ((test-fn (dylan::find-keyword rest 'test:
  98.                     (lambda () dylan:id?))))
  99.       (if (iterate-until (lambda (x) (dylan-call test-fn x object)) seq)
  100.       seq
  101.       (dylan-call dylan:add! seq object))))))
  102.  
  103. (define dylan:remove
  104.   (dylan::generic-fn
  105.    'remove
  106.    (make-param-list `((SEQUENCE ,<sequence>) (VALUE ,<object>))
  107.             #F #F '(test: count:))
  108.    #F))
  109.  
  110. (add-method
  111.  dylan:remove
  112.  (dylan::dylan-callable->method
  113.   (make-param-list `((SEQUENCE ,<sequence>) (VALUE ,<object>))
  114.            #F #F '(test: count:))
  115.   (lambda (multiple-values next-method seq value . rest)
  116.     multiple-values
  117.     (dylan::keyword-validate next-method rest '(test: count:))
  118.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?)))
  119.       (count (dylan::find-keyword rest 'count: (lambda () -1))))
  120.       (let loop ((state (dylan-call dylan:initial-state seq))
  121.          (rt specialized for argument" seq-1 rest))))
  122.  
  123. (define dylan:replace-subsequence!
  124.   (dylan::generic-fn
  125.    'replace-subsequence!
  126.    (make-param-list `((MUTABLE-SEQUENCE ,<mutable-sequence>)
  127.               (INSERT-SEQUENCE ,<sequence>))
  128.             #F #F '(start:))
  129.    #F))
  130.  
  131. (add-method
  132.  dylan:replace-subsequence!
  133.  (dylan::dylan-callable->method
  134.   (make-param-list `((MUTABLE-SEQUENCE ,<mutable-sequence>)
  135.              (INSERT-SEQUENCE ,<sequence>))
  136.            #F #F '(start:))
  137.   (lambda (multiple-values next-method mutable insert . rest)
  138.     multiple-values
  139.     (dylan::keyword-validate next-method rest '(start:))
  140.     (let ((start (dylan::find-keyword rest 'start: (lambda () 0)))
  141.       (m-state (dylan-call dylan:initial-state mutable)))
  142.       (if (< (- (dylan-call dylan:size mutable) start)
  143.          (dylan-call dylan:size insert))
  144.       (dylan-call dylan:error
  145.               "replace-subsequence! -- not enough elements in target"
  146.               mutable insert start))
  147.       (if (negative? start)
  148.       (dylan-call dylan:error
  149.               "replace-subsequence! -- index cannot be negative"
  150.               mutable insert start))
  151.       (do ((count 0 (+ count 1)))
  152.       ((= count start) 'done)
  153.     (set! m-state (dylan-call dylan:next-state mutable m-state)))
  154.       (let loop ((i-state (dylan-call dylan:initial-state insert))
  155.          (m-state m-state))
  156.     (if i-state
  157.         (begin
  158.           (dylan-call
  159.            dylan:setter/current-element/
  160.            mutable m-state
  161.            (dylan-call dylan:current-element insert i-state))
  162.           (loop (dylan-call dylan:next-state insert i-state)
  163.             (dylan-call dylan:next-state mutable m-state)))
  164.         mutable))))))
  165.  
  166.  
  167. (define dylan:reverse
  168.   (dylan::generic-fn 'reverse
  169.     one-sequence
  170.     (lambda (seq-1)
  171.       (dylan-call dylan:error
  172.           "reverse -- not defined for this sequence type" seq-1))))
  173.  
  174.  
  175. (define dylan:reverse!
  176.   (dylan::generic-fn 'reverse!
  177.     one-sequence
  178.     (lambda (seq-1)
  179.       (dylan-call dylan:reverse seq-1))))
  180.  
  181.  
  182. (define dylan:sort
  183.   (dylan::generic-fn
  184.    'sort
  185.    (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test: stable:))
  186.    #F))
  187.  
  188. (add-method
  189.  dylan:sort
  190.  (dylan::dylan-callable->method
  191.   (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test: stable:))
  192.   (lambda (multiple-values next-method seq . rest)
  193.     multiple-values
  194.     (dylan::keyword-validate next-method rest '(test: stable:))
  195.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:<)))
  196.       (stable (dylan::find-keyword rest 'stable: (lambda () #F))))
  197.       stable            ; Ignored
  198.       (dylan-call dylan:as
  199.           (dylan-call dylan:class-for-copy seq)
  200.           (sort (dylan-call dylan:as <list> seq)
  201.             (lambda (x y)
  202.               (dylan-call test? x y))))))))
  203.  
  204. (define dylan:sort!
  205.   (dylan::generic-fn
  206.    'sort!
  207.    (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test: stable:))
  208.    #F))
  209.  
  210. (add-method
  211.  dylan:sort!
  212.  (dylan::dylan-callable->method
  213.   (make-param-list `((SEQUENCE ,<sequence>)) #F #F '(test: stable:))
  214.   (lambda (multiple-values next-method seq . rest)
  215.     multiple-values
  216.     (dylan::keyword-validate next-method rest '(test: stable:))
  217.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:<)))
  218.       (stable (dylan::find-keyword rest 'stable: (lambda () #F))))
  219.       (dylan-call dylan:sort seq 'test: test? 'stable: stable)))))
  220.  
  221. (define dylan:first
  222.   (dylan::generic-fn 'first
  223.     one-sequence
  224.     (lambda (sequence-1)
  225.       (let ((state (dylan-call dylan:initial-state sequence-1)))
  226.     (if state
  227.         (dylan-call dylan:current-element sequence-1 state)
  228.         (dylan-call dylan:error
  229.             "first -- no element in sequence" sequence-1))))))
  230.  
  231. (define dylan:second
  232.   (dylan::generic-fn 'second
  233.     one-sequence
  234.     (lambda (sequence-1)
  235.       (let ((state (dylan-call dylan:get-state sequence-1 1)))
  236.     (if state
  237.         (dylan-call dylan:current-element sequence-1 state)
  238.         (dylan-call dylan:error
  239.             "second -- sequence size < 2" sequence-1))))))
  240.  
  241. (define dylan:third
  242.   (dylan::generic-fn 'third
  243.     one-sequence
  244.     (lambda (sequence-1)
  245.       (let ((state (dylan-call dylan:get-state sequence-1 2)))
  246.     (if state
  247.         (dylan-call dylan:current-element sequence-1 state)
  248.         (dylan-call dylan:error
  249.             "third -- sequence size < 3" sequence-1))))))
  250.  
  251.  
  252. (define dylan:setter/first/
  253.   (dylan::generic-fn 'setter/first/
  254.     one-mutable-sequence-and-an-object
  255.     (lambda (sequence-1 new-value)
  256.       (let ((state (dylan-call dylan:initial-state sequence-1)))
  257.     (if state
  258.         (begin
  259.           (dylan-call
  260.            dylan:setter/current-element/ sequence-1 state new-value)
  261.           new-value)
  262.         (dylan-call dylan:error
  263.             "(setter first) -- sequence is empty"
  264.             sequence-1 new-value))))))
  265.  
  266. (define dylan:setter/second/
  267.   (dylan::generic-fn 'setter/first/
  268.     one-mutable-sequence-and-an-object
  269.     (lambda (sequence-1 new-value)
  270.       (let ((size (dylan-call dylan:size sequence-1)))
  271.     (if (or (not size) (>= size 2))
  272.         (begin
  273.           (dylan-call dylan:setter/current-element/
  274.               sequence-1
  275.               (dylan-call dylan:get-state sequence-1 1)
  276.               new-value)
  277.           new-value)
  278.         (dylan-call dylan:error
  279.             "(setter second) -- sequence size < 2"
  280.             sequence-1 new-value))))))
  281.  
  282. (define dylan:setter/third/
  283.   (dylan::generic-fn 'setter/first/
  284.     one-mutable-sequence-and-an-object
  285.     (lambda (sequence-1 new-value)
  286.       (let ((size (dylan-call dylan:size sequence-1)))
  287.     (if (or (not size) (>= size 3))
  288.         (begin
  289.           (dylan-call dylan:setter/current-element/
  290.               sequence-1
  291.               (dylan-call dylan:get-state sequence-1 2)
  292.               new-value)
  293.           new-value)
  294.         (dylan-call dylan:error
  295.             "(setter third) -- sequence size < 3"
  296.             sequence-1 new-value))))))
  297.  
  298. (define dylan:last
  299.   (dylan::generic-fn 'last
  300.     one-sequence
  301.     (lambda (sequence-1)
  302.       (let ((prev-state #F))
  303.     (do ((state (dylan-call dylan:initial-state sequence-1)
  304.             (dylan-call dylan:next-state sequence-1 state)))
  305.         ((not state)
  306.          (if prev-state
  307.          (dylan-call dylan:current-element sequence-1 prev-state)
  308.          (dylan-call dylan:error
  309.                  "last -- sequence is empty" sequence-1)))
  310.       (set! prev-state state))))))
  311.  
  312. (define (check-subsequence test? big big-state pattern pattern-state)
  313.   (define (check-loop big-state pattern-state)
  314.     (if (not pattern-state)
  315.     #T
  316.     (if (and big-state
  317.          (dylan-call test?
  318.                  (dylan-call dylan:current-element big big-state)
  319.           (dylan-call dylan:current-element pattern pattern-state)))
  320.         (check-loop
  321.          (dylan-call dylan:next-state big big-state)
  322.          (dylan-call dylan:next-state pattern pattern-state))
  323.         #F)))
  324.   (check-loop (dylan-call dylan:copy-state big big-state)
  325.           (dylan-call dylan:copy-state pattern pattern-state)))
  326.  
  327. (define dylan:subsequence-position
  328.   (dylan::generic-fn
  329.    'subsequence-position
  330.    (make-param-list
  331.     `((BIG ,<sequence>) (PATTERN ,<sequence>)) #F #F '(test: count:))
  332.    #F))
  333.  
  334. (add-method
  335.  dylan:subsequence-position
  336.  (dylan::dylan-callable->method
  337.   (make-param-list
  338.    `((BIG ,<sequence>) (PATTERN ,<sequence>)) #F #F '(test: count:))
  339.   (lambda (multiple-values next-method big pattern . rest)
  340.     multiple-values
  341.     (dylan::keyword-validate next-method rest '(test: count:))
  342.     (let ((test? (dylan::find-keyword rest 'test: (lambda () dylan:id?)))
  343.       (count (dylan::find-keyword rest 'count: (lambda () 1)))
  344.       (first-of-pattern (dylan-call dylan:first pattern))
  345.       (init-state-pattern (dylan-call dylan:initial-state pattern)))
  346.       (let loop ((state (dylan-call dylan:initial-state big))
  347.          (num-found 0)
  348.          (index 0))
  349.     (if state
  350.         (if (and (dylan-call test?
  351.                  (dylan-call dylan:current-element big state)
  352.                  first-of-pattern)
  353.              (check-subsequence test? big state
  354.                     pattern init-state-pattern))
  355.         (if (>= num-found (- count 1))
  356.             index
  357.             (loop (dylan-call dylan:next-state big state)
  358.               (+ num-found 1)
  359.               (+ index 1)))
  360.         (loop (dylan-call dylan:next-state big state)
  361.               num-found
  362.               (+ index 1)))
  363.         #F))))))            ; not found
  364.  
  365. ;;;;
  366. ;;;; MUTABLE COLLECTIONS (p. 127)
  367. ;;;;
  368.  
  369. (define dylan:setter/current-element/
  370.   (dylan::generic-fn 'setter/current-element/
  371.     (make-param-list `((MUTABLE-COLLECTION ,<mutable-collection>)
  372.                (STATE ,<object>)
  373.                (NEW-VALUE ,<object>))
  374.              #F #F #F)
  375.     (lambda (mutable-collection state new-value)
  376.       (dylan-call dylan:error
  377.           "(setter current-element) -- cannot set! this collection type"
  378.           mutable-collection state new-value))))
  379.  
  380. (define dylan:setter/element/
  381.   (dylan::generic-fn 'setter/element/
  382.     (make-param-list `((MUTABLE-COLLECTION ,<mutable-collection>)
  383.                (KEY ,<object>)
  384.                (NEW-VAL ,<object>))
  385.              #F #F #F)
  386.     (lambda (collection key new-value)
  387.       (dylan-call dylan:error
  388.           "(setter element) -- not defined for this collection type"
  389.           collection key new-value))))
  390.  
  391. (add-method dylan:setter/element/
  392.   (dylan::function->method
  393.    (make-param-list `((MUTABLE-SEQUENCE ,<mutable-sequence>)
  394.               (KEY ,<integer>)
  395.               (NEW-VALUE ,<object>))
  396.             #F #F #F)
  397.    (lambda (mut-seq key new-value)
  398.      (do ((state (dylan-call dylan:initial-state mut-seq)
  399.          (dylan-call dylan:next-state mut-seq state))
  400.       (k 0 (+ k 1)))
  401.      ((or (not state) (= k key))
  402.       (if state
  403.           (begin
  404.         (dylan-call dylan:setter/current-element/
  405.                 mut-seq state new-value)
  406.         new-value)
  407.           (dylan-call dylan:error
  408.               "(setter element) -- key not found"
  409.               mut-seq key new-value)))))))
  410.  
  411. (add-method dylan:setter/element/
  412.   (dylan::function->method
  413.    (make-param-list
  414.     `((MUTABLE-EXPLICIT-KEY-COLLECTION ,<mutable-explicit-key-collection>)
  415.       (KEY ,<object>)
  416.       (NEW-VALUE ,<object>))
  417.     #F #F #F)
  418.    (lambda (mut-seq key new-value)
  419.      (do ((state (dylan-call dylan:initial-state mut-seq)
  420.          (dylan-call dylan:next-state mut-seq state)))
  421.      ((or (not state) (dylan-call
  422.                dylan:=
  423.                (dylan-call dylan:current-key mut-seq state)
  424.                key))
  425.       (if state
  426.           (begin
  427.         (dylan-call dylan:setter/current-element/
  428.                 mut-seq state new-value)
  429.         new-value)
  430.           (dylan-call dylan:error
  431.               "(setter element) -- key not found"
  432.               mut-seq key new-value)))))))
  433.